perm filename GEMFIX.LSP[GEL,BGB] blob
sn#239339 filedate 1976-10-05 generic text, type T, neo UTF8
(DEFPROP GEMFIXFNS
(GEMFIXFNS GEMSETQ
LISPSETQ
COMMENT
ENTER
SETQ
*ERRORX
GEMFIX
LISP
ERRORX
GEMTOP
XWC/.
YWC/.
ZWC/.
(COND ((ERRSET GEMVARS NIL) NIL) (T (SETQ GEMVARS NIL)))
(COMMENT (MODCHR (CHRVAL (QUOTE /.)) (MODCHR (CHRVAL (QUOTE A)) NIL))))
VALUE)
(DEFPROP COMMENT
(LAMBDA(L) NIL)
EXPR)
(DEFPROP ENTER
(LAMBDA (X L) (COND ((MEMBER X L) L) (T (CONS X L))))
EXPR)
(DEFPROP GEMSETQ
(LAMBDA(X Y)
(PROG2 (DEPOSIT (MAKNUM (CDDR X))
(COND ((EQ (CADR X) (QUOTE FIXNUM)) (FIX Y))
(T (MAKNUM (NUMVAL (*PLUS Y 0)) (QUOTE FIXNUM)))))
Y))
EXPR)
(DEFPROP LISPSETQ
(LAMBDA (L) (PROG2 (PUTPROP (QUOTE LISPSETQ) (GET (QUOTE SETQ) (QUOTE FSUBR)) (QUOTE FSUBR)) L))
MACRO)
(DEFPROP SETQ
(LAMBDA(SETQ-L)
(PROG (SETQ-TMP)
(RETURN
(COND ((EQ (CAR (LISPSETQ SETQ-TMP (GET (CADR SETQ-L) (QUOTE VALUE)))) (QUOTE GEMVAL))
(RPLACA SETQ-L (QUOTE GEMSETQ)))
(SETQ-TMP (RPLACA SETQ-L (QUOTE LISPSETQ)))
((GEMFIX (CADR SETQ-L)) (RPLACA SETQ-L (QUOTE GEMSETQ)))
(T (RPLACA SETQ-L (QUOTE LISPSETQ)))))))
MACRO)
(DEFPROP *ERRORX
(LAMBDA NIL (PROG2 (PUTPROP (QUOTE *ERRORX) (GET (QUOTE ERRORX) (QUOTE SUBR)) (QUOTE SUBR)) (*ERRORX)))
EXPR)
(DEFPROP GEMFIX
(LAMBDA(L)
(COND ((ATOM L)
(COND ((*GETSYM L)
(PROG2 (LISPSETQ GEMVARS (ENTER L GEMVARS))
(PUTPROP
L
(CONS (QUOTE GEMVAL)
(CONS (CAR NIL)
(CONS (COND ((*LESS (ABS (EXAMINE (*GETSYM L))) 777777777) (QUOTE FIXNUM))
(T (QUOTE FLONUM)))
(NUMVAL (*GETSYM L)))))
(QUOTE VALUE))))
(T NIL)))
((ATOM (CAR L))
(COND ((GETL (CAR L) (QUOTE (SUBR FSUBR LSUBR EXPR FEXPR MACRO))) NIL)
((*GETSYM (CAR L))
(PROG2 (SETQ GEMVARS (ENTER (CAR L) GEMVARS))
(PUTPROP (CAR L) (NUMVAL (*GETSYM (CAR L))) (QUOTE SUBR))))
(T NIL)))
(T NIL)))
EXPR)
(DEFPROP LISP
(LAMBDA NIL (PROG NIL LOOP (TERPRI) (PRINT (EVAL (READ))) (GO LOOP)))
EXPR)
(DEFPROP ERRORX
(LAMBDA NIL
(PROG (ERRORX-LASTPOS)
(RETURN
(COND ((AND (LISPSETQ ERRORX-LASTPOS (NEXTEV (SUB1 (STKSRCH (QUOTE ERRORX) (SPDLPT) NIL))))
(GEMFIX (SPDLRT ERRORX-LASTPOS)))
(PROG2 (PRINT (QUOTE (EXTERNAL FOUND))) (SPREDO ERRORX-LASTPOS)))
(T (*ERRORX))))))
EXPR)
(DEFPROP GEMTOP
(LAMBDA NIL (PRINC (QUOTE "GEOMED embedded in LISP")))
EXPR)
(COND ((ERRSET GEMVARS NIL) NIL) (T (SETQ GEMVARS NIL)))
(COMMENT (MODCHR (CHRVAL (QUOTE $)) (MODCHR (CHRVAL (QUOTE A)) NIL)))